home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 7.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  36.3 KB  |  1,211 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #include "hdr.h"
  10. #include "libhdr.h"
  11. #include "vars.h"
  12. #include "setprots.h"
  13. #include "errmsgprots.h"
  14. #include "dclmapprots.h"
  15. #include "libprots.h"
  16. #include "miscprots.h"
  17. #include "unitsprots.h"
  18. #include "nodesprots.h"
  19. #include "smiscprots.h"
  20. #include "chapprots.h"
  21. /* TBSL: check that check_priv_decl always called with first
  22.     argument (kind) as integer, corresponding to MISC_TYPE_ATTRIBUTE...
  23.  */
  24.  
  25. static int in_relevant_scopes(int);
  26. static Symbol trace_ancestor(Symbol, Tuple);
  27. static void private_part(Node);
  28.  
  29. void package_specification(Node node)    /*; package specification */
  30. {
  31.     Node    id_node, decl_node, priv_node;
  32.  
  33.     id_node   = N_AST1(node);
  34.     decl_node = N_AST2(node);
  35.     priv_node = N_AST3(node);
  36.     new_package(id_node, na_package_spec);
  37.     package_declarations(decl_node, priv_node);
  38.     end_specs(N_UNQ(id_node));
  39. }
  40.  
  41. void new_package(Node id_node, int nat)    /*;new_package*/
  42. {
  43.     /* Process a  package specification: install scope, initialize  mappings. */
  44.  
  45.     char    *id;
  46.     Symbol    ud;
  47.     int        body_number;
  48.  
  49.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  new_package");
  50.  
  51.     id = N_VAL(id_node);
  52.     new_compunit("sp", id_node);
  53.     if (nat==na_generic_part && IS_COMP_UNIT) {
  54.             /* allocate unit number for body, and mark it obsolete */
  55.             body_number = unit_number(strjoin("bo", id));
  56.             pUnits[body_number]->libInfo.obsolete = string_ds; /*"$D$"*/
  57.     }
  58.     newmod(id);
  59.  
  60.     N_UNQ(id_node) = scope_name;
  61.     NATURE(scope_name)  = nat;
  62.     TYPE_OF(scope_name) = symbol_none;
  63.     /* Create dummy entry to hold use clauses, which are declarative items.*/
  64.     find_new("$used");
  65.     /* use_declarations in SETL is signature(declared(scope_name), '$used') */
  66.     ud = dcl_get(DECLARED(scope_name), "$used");
  67.     SIGNATURE(ud) = tup_new(0);
  68.     private_decls(scope_name) = (Set) private_decls_new(0);
  69. }
  70.  
  71. void package_declarations(Node decl_node, Node priv_node)
  72.                                                     /*;package_declarations */
  73. {
  74.     char    *str;
  75.     Symbol    s1, u_name;
  76.     Fordeclared dcliv;
  77.  
  78.     adasem(decl_node);
  79.     /* The declarations so far constitute the visible part of the package*/
  80.     /* save current declarations */
  81.     /*    visible(scope_name) = declared(scope_name); */
  82.     FORDECLARED(str, s1, DECLARED(scope_name), dcliv);
  83.         IS_VISIBLE(dcliv) = TRUE;
  84.     ENDFORDECLARED(dcliv);
  85.  
  86.     FORDECLARED(str, u_name, DECLARED(scope_name), dcliv)
  87.         if (TYPE_OF(u_name) == symbol_incomplete) {
  88. #ifdef ERRNUM
  89.         id_errmsgn(4, u_name, 5, decl_node);
  90. #else
  91.         errmsg_id("missing full declaration for %", u_name, "3.8.1", decl_node);
  92. #endif
  93.         }
  94.     ENDFORDECLARED(dcliv);
  95.     /* Now process private part of package.*/
  96.     private_part(priv_node);
  97. }
  98.  
  99. void module_body_id(int mod_nature, Node name_node)  /*;module_body_id*/
  100. {
  101.     /* This procedure is invoked when the name of a module body has been
  102.      * seen. It opens the new scope, and if necessary retrieves from the
  103.      * library the specifications for the module.
  104.      */
  105.  
  106.     Symbol    mod_name, c, real_t;
  107.     char    *spec_name;
  108.     int    nat, mattr, mark;
  109.     char    *id;
  110.     Symbol    s1, s2, t;
  111.     Fordeclared    fd1;
  112.     Forprivate_decls    fp1;
  113.     Private_declarations    pd;
  114.     Tuple    ud;
  115.     Symbol    uds; /* check tupe of this    ds 4 aug */
  116.     Fortup    ft1;
  117.  
  118.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  module_body_id");
  119.  
  120.     new_compunit("bo", name_node);
  121.  
  122.     find_old(name_node);
  123.     mod_name = N_UNQ(name_node);
  124.     if (!IS_COMP_UNIT && SCOPE_OF(mod_name) != scope_name) {
  125. #ifdef ERRNUM
  126.         errmsgn(394, 16, name_node);
  127. #else
  128.         errmsg("Specification and body are in different scopes" , "7.1, 9.1",
  129.           name_node);
  130. #endif
  131.     }
  132.  
  133.     /* Nature of specification must match that of current body*/
  134.  
  135.     /*
  136.      * const specs_of = { 
  137.      *     [na_package, {na_package_spec, na_generic_package_spec}],
  138.      *     [na_task_type, {na_task_type_spec, na_task_obj_spec}] };
  139.      * if (NATURE(mod_name) in specs_of(mod_nature) ) {
  140.      *     rmatch(nature(mod_name), '_spec');        $ not a spec any longer 
  141.      * }
  142.      */
  143.     nat = NATURE(mod_name);
  144.     if (mod_nature == na_package
  145.       && (nat == na_package_spec || nat == na_generic_package_spec)
  146.       || (mod_nature == na_task_type && (nat == na_task_type_spec
  147.       || nat == na_task_obj_spec 
  148.       || (nat == na_obj && NATURE(TYPE_OF(mod_name)) == na_task_type_spec)))) {
  149.         /* if the task appeared in a previously (separately) compiled unit,
  150.           * the expander has already changed its nature to na_obj
  151.           */
  152.         if (nat == na_package_spec) nat = na_package;
  153.         else if (nat == na_generic_package_spec)
  154.             nat = na_generic_package;
  155.         else if (nat == na_task_type_spec)
  156.             nat = na_task_type;
  157.         else if (nat == na_task_obj_spec)
  158.             nat = na_task_obj;
  159.         else if (nat == na_obj)
  160.             NATURE(TYPE_OF(mod_name)) = na_task_type;
  161.  
  162.         NATURE(mod_name) = nat;
  163.     }
  164.     else {
  165. #ifdef ERRNUM
  166.         nval_errmsgn(395, name_node, 16, name_node);
  167. #else
  168.         errmsg_nval("Matching specification not found for body %", name_node,
  169.           "7.1, 9.1", name_node);
  170. #endif
  171.     }
  172.  
  173.     /* if module is a generic package body and the current unit is a package
  174.      * body, verify that the generic spec appeared in the same file.
  175.      */
  176.     if (NATURE(mod_name) == na_generic_package 
  177.       && streq(unit_name_type(unit_name), "bo")) {
  178.         if (is_subunit(unit_name))
  179.             spec_name = pUnits[stub_parent_get(unit_name)]->name;
  180.         else
  181.             spec_name = strjoin("sp", unit_name_name(unit_name));
  182.         if (!streq(lib_unit_get(spec_name), AISFILENAME))
  183. #ifdef ERRNUM
  184.             errmsgn(35, 10, name_node);
  185. #else
  186.             errmsg("Separately compiled generics not supported", "none",
  187.               name_node);
  188. #endif
  189.     }
  190.  
  191.     newscope (mod_name);    /* added to match SETL    gcs 23 jan */
  192.     if (private_decls(mod_name) == (Set)0)
  193.         private_decls(mod_name) = (Set) private_decls_new(0);
  194.     /* For safe processing of body.*/
  195.     if (DECLARED(mod_name) == (Declaredmap)0)
  196.         DECLARED(mod_name) = dcl_new(0);
  197.  
  198.     if (NATURE(mod_name) == na_task_type ) {
  199.         /* Within the body of a task type, the name of the task can be used 
  200.          * to designate the task currently executing the body. We create an 
  201.          * alias to be elaborated at run-time, under the name 'current_task'.
  202.          */
  203.         c = find_new(strjoin("", "current_task"));
  204.         TYPE_OF(c) = mod_name;
  205.         NATURE(c) = na_obj;
  206.     }
  207.     else if (NATURE(mod_name) == na_task_obj ) {
  208.         /* remove -spec marker from its anonymous task type as well.*/
  209.         NATURE(TYPE_OF(mod_name)) = na_task_type;
  210.     }
  211.     else if (mod_nature == na_package ) {
  212.         /* Within a package body, declarations from the private part of the
  213.          * specification are     visible. Swap    visible and  private versions.
  214.          */
  215.         pd = (Private_declarations) private_decls(mod_name);
  216.         FORPRIVATE_DECLS(s1, s2, pd, fp1);
  217.             private_decls_swap(s1, s2);
  218.         ENDFORPRIVATE_DECLS(fp1);
  219.         /* (forall [item, pdecl] in private_decls(mod_name))
  220.          * [SYMBTABF(item), private_decls(mod_name)(item)] :=
  221.          * [pdecl, SYMBTABF(item)];    
  222.          * end forall;
  223.          */
  224.         /* Furthermore, composite types that depend on (outer) private types
  225.          * may now be fully useable if the latter received full declarations,
  226.          * (as long as they do not depend in external private types...)
  227.          */
  228.         FORDECLARED(id, t, DECLARED(mod_name), fd1);
  229.             if (NATURE(t) == na_package_spec && !tup_mem((char *) t, vis_mods) )
  230.                 vis_mods = tup_with(vis_mods, (char *) t);
  231.             else if (! is_type(t)) continue;
  232.             mattr = (int) misc_type_attributes(t);
  233.             mark = 0;
  234.             if (mattr & TA_PRIVATE)
  235.                 mark = TA_PRIVATE;
  236.             else if (mattr & TA_LIMITED_PRIVATE)
  237.                 mark = TA_LIMITED_PRIVATE;
  238.             /* exclude the mark 'limited' from this test (gs apr 1 85) */
  239.             /* else if (mattr & TA_LIMITED)
  240.              * mark = TA_LIMITED;
  241.              */
  242.             else if (mattr & TA_INCOMPLETE)
  243.                 mark = TA_INCOMPLETE;
  244.             if (mark == 0) continue;
  245.             if (is_access(t)) real_t = (Symbol) designated_type(t);
  246.             else real_t = t;
  247.  
  248.             if (!is_private(real_t) ) {
  249.                 /* full declaration  of private ancestor(s) has been seen.
  250.                  * save visible declaration before updating.
  251.                  */
  252.                 private_decls_put((Private_declarations)
  253.                   private_decls(mod_name), t);
  254.                 misc_type_attributes(t) = (misc_type_attributes(t) & ~mark );
  255.             }
  256.         ENDFORDECLARED(fd1);
  257.         /* and install the use clauses that were encountered in the
  258.          * specification.
  259.          */
  260.         uds = dcl_get(DECLARED(mod_name), "$used");
  261.         if ( uds != (Symbol)0 ) {
  262.             ud = SIGNATURE(uds);
  263.             FORTUP(uds=(Symbol), ud, ft1);
  264.                 used_mods = tup_with(used_mods, (char *) uds);
  265.             ENDFORTUP(ft1);
  266.         }
  267.         /* Else the body was not found. Error was emitted already.*/
  268.     }
  269.  
  270.     /* Initialize the stacks used for label processing.*/
  271.     lab_init();
  272. }
  273.  
  274. void module_body(int nat, Node block_node)    /*;module_body*/
  275. {
  276.  
  277.     Symbol    mod_name, scope;
  278.     char    *spec_name;
  279.     Tuple        specs, nodes, context;
  280.     Node    decls, stats, except, id_node;
  281.     Symbol    u_name;
  282.     Tuple    tup;
  283.     int    i;
  284.     Symbol    s1, s2;
  285.     Forprivate_decls    fp1;
  286.     Private_declarations    pd;
  287.     Fordeclared        fd1;
  288.     Fortup            ft1;
  289.     Tuple        scopes, must_constrain;
  290.     Unitdecl    ud;
  291.     char    *utnam;
  292.     char    *did;
  293.     Symbol    t_name, unit_unam;
  294.     Tuple    old_vis;
  295.     int    scopei;
  296.     Tuple    decmaps, decscopes, gen_list;
  297.  
  298.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  module_body");
  299.  
  300.     mod_name = scope_name;
  301.     decls = N_AST2(block_node);
  302.     stats = N_AST3(block_node);
  303.     except = N_AST4(block_node);
  304.     /* Each task type can refer to an instance of itself; dynamically,
  305.      * such an instance is constructed under the name 'current_task'. We
  306.      * introduce a declaration for a dummy task object with taht name.
  307.      */
  308.     if (NATURE(mod_name) == na_task_type) {
  309.         id_node = node_new(as_simple_name);
  310.         N_VAL(id_node) = strjoin("", "current_task");
  311.         find_old(id_node);
  312.         N_KIND(id_node) = as_current_task;
  313.         copy_span(N_AST1(block_node), id_node);
  314. #ifdef TBSN
  315.         SPANS(id_node)    = [left_span(decls)];
  316. #endif
  317.         /*N_LIST(decls) := [id_node] + N_LIST(decls) */
  318.         tup = N_LIST(decls);
  319.         tup = tup_exp(tup, (unsigned) tup_size(tup)+1);
  320.         for (i=tup_size(tup);i>1;i--)
  321.             tup[i] = tup[i-1];
  322.         tup[1] = (char *) id_node;
  323.         N_LIST(decls) = tup;
  324.     }
  325.  
  326.     lab_end();
  327.     check_incomplete_decls(mod_name, block_node);
  328.     popscope()    ;
  329.     /* Having finished the module body, we now restore the visible
  330.      * declarations saved in module_body_id (If it is a package).
  331.      */
  332.     if (nat == na_package  || nat == na_generic_package) {
  333.         pd = (Private_declarations) private_decls(mod_name);
  334.         FORPRIVATE_DECLS(s1, s2, pd, fp1);
  335.             private_decls_swap(s1, s2);
  336.         ENDFORPRIVATE_DECLS(fp1);
  337.     }
  338.  
  339.     if (NATURE(mod_name) == na_generic_package) {
  340.         /* We must update the declarations for the current unit, to
  341.          * include  the generic body. This  can be  done  omly if the
  342.          * generic  specification appears in the current compilation,
  343.          * which is a restriction on the current  implementation that
  344.          * will be lifted some day.
  345.          * For purposes of generic instantiation, we must save not only
  346.          * the visible part of the package, but all declarations in the
  347.          * body as well, including declarations     for nested non-generic
  348.          * objects. This parallels what is done at the point of instan-
  349.          * tiation. 
  350.          *
  351.          * Replace the opt_node that marks the place of the body in the 
  352.          * generic spec, with the body node.
  353.          * Set fifth component of signature to tuple of generic private types
  354.          * that must be constrained upon instantiation.
  355.          */
  356.  
  357.         SIGNATURE(mod_name)[4] = (char *) block_node;
  358.         gen_list = (Tuple) SIGNATURE(mod_name)[1];
  359.         must_constrain = tup_new(0);
  360.         FORTUP(tup=(Tuple), gen_list, ft1)
  361.             t_name = (Symbol)tup[1];
  362.             if ((int)misc_type_attributes(t_name) & TA_CONSTRAIN)
  363.                 must_constrain=tup_with(must_constrain, (char *)t_name);
  364.         ENDFORTUP(ft1);
  365.         SIGNATURE(mod_name)[5] = (char *) must_constrain;
  366.  
  367.         utnam = unit_name_type(unit_name);
  368.         if (IS_COMP_UNIT) {
  369.             pUnits[unit_number(unit_name)]->libInfo.obsolete = string_ok;
  370. #ifdef IBM_PC
  371.             pUnits[unit_number(unit_name)]->libInfo.obsolete = strjoin("ok", "");
  372. #endif
  373.         }
  374.         if (streq(utnam, "bo") || streq(utnam, "su")
  375.           && streq(unit_name_name(unit_name), unit_name_names(unit_name)) ){
  376.             spec_name = strjoin("sp", unit_name_name (unit_name));
  377.             if (lib_unit_get(spec_name) != (char *)0
  378.               && streq(lib_unit_get(spec_name) , AISFILENAME)
  379.               && unit_decl_get(spec_name)!=(Unitdecl)0 ) {
  380.                 /* Unpack unit specification.*/
  381.                 ud = unit_decl_get(spec_name);
  382.                 unit_unam = ud->ud_unam;
  383.                 /*specs = utup[5];*/
  384.                 specs = ud->ud_symbols;
  385.                 decscopes = ud->ud_decscopes;
  386.                 old_vis = ud->ud_oldvis;
  387.                 decmaps = ud->ud_decmaps;
  388.                 scopes = tup_new1((char *) mod_name);
  389.                 nodes = ud->ud_nodes;
  390.                 context =ud->ud_context;
  391.  
  392.                 /*  Update the specs of generic types, that may carry the
  393.                  * marker "$constrain', because of usage in body.
  394.                  */
  395.                 FORDECLARED(did, t_name, DECLARED(mod_name), fd1);
  396.                     if( is_generic_type(t_name))
  397.                         /*specs(t_name) := SYMBTABF(t_name);*/
  398.                         specs = sym_save(specs, t_name, 'u');
  399.                 ENDFORDECLARED(fd1);
  400.                 while (tup_size(scopes) >0) {
  401.                     scope =(Symbol) tup_frome(scopes);
  402.  
  403.                     /*specs(scope)  = SYMBTABF(scope);*/
  404.                     specs = sym_save(specs, scope, 'u');
  405.                     scopei = tup_memi((char *) scope, decscopes);
  406.                     if (scopei == 0) {
  407.                         decscopes = tup_exp(decscopes,
  408.                           (unsigned) tup_size(decscopes)+1);
  409.                         decmaps = tup_exp(decmaps,
  410.                           (unsigned) tup_size(decmaps)+1);
  411.                         scopei = tup_size(decscopes);
  412.                         decscopes[scopei] = (char *) scope;
  413.                     }
  414.                     decmaps[scopei] = (char *) dcl_copy(DECLARED(scope));
  415.                     /* body_decls      = declared(scope) -
  416.                      *   (visible(scope) ? {});
  417.                      * notvis(scope) = body_decls;
  418.                      */
  419.                     /* TBSL: Review following when do generics    ds 1 aug */
  420.                     /*(forall [-, u_name] in body_decls)*/
  421.                     FORDECLARED(did, u_name, DECLARED(scope), fd1);
  422.                         if (IS_VISIBLE(fd1)) continue;
  423.                         /*specs(u_name) := SYMBTABF(u_name);*/
  424.                         specs = sym_save(specs, u_name, 'u');
  425.  
  426.                         if (DECLARED(u_name) != (Declaredmap)0
  427.                           && ! can_overload(u_name)
  428.                           && NATURE(u_name) != na_generic_package)
  429.                             /* Contains further collectible decls.*/
  430.                             if (!tup_mem((char *) u_name, scopes))
  431.                                 scopes = tup_with(scopes, (char *) u_name);
  432.                     ENDFORDECLARED(fd1);
  433.                 }
  434.                 /*specs(mod_name) := SYMBTABF(mod_name);*/
  435.                 specs = sym_save(specs, mod_name, 'u');
  436.                 /* Repackage the unit's information.*/
  437.                 /* UNIT_DECL(spec_name) :=
  438.                  * [unit_unam, specs, decmap, old_vis, notvis, context,
  439.                  * nodes with block_node];
  440.                  */
  441.                 ud = unit_decl_get(spec_name);
  442.                 if (ud == (Unitdecl)0) ud = unit_decl_new();
  443.                 /* TBSL see if tup_copy's needed before saving tuples in utup */
  444.                 ud->ud_unam = unit_unam;
  445.                 ud->ud_useq = S_SEQ(unit_unam);
  446.                 ud->ud_unit = S_UNIT(unit_unam);
  447.                 ud->ud_symbols = specs;
  448.                 ud->ud_decscopes = decscopes;
  449.                 ud->ud_oldvis = old_vis;
  450.                 ud->ud_decmaps = decmaps;
  451.                 ud->ud_context = tup_copy(context);
  452.                 ud->ud_nodes = tup_with(nodes, (char *) block_node);
  453.                 unit_decl_put(spec_name, ud);
  454.             }
  455.             else if (IS_COMP_UNIT) {
  456.                 /* Repackage as a specification. */
  457.  
  458.                 newscope(mod_name);    /* For end_specs*/
  459.                 end_specs(mod_name);
  460.             }
  461.         }
  462.     } /* end if na_generic_package() */
  463.  
  464.     if (nat != na_task) save_body_info(mod_name);
  465. }
  466.  
  467. void private_decl(Node node)    /*;private_decl*/
  468. {
  469.     char    *id, *priv_kind_str;
  470.     Symbol    name, priv_kind;
  471.     Node    id_node, opt_discr, priv_kind_node;
  472.     int    nat;
  473.  
  474.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  private_decl");
  475.  
  476.     id_node = N_AST1(node);
  477.     opt_discr = N_AST2(node);
  478.     priv_kind_node = N_AST3(node);
  479.  
  480.     id = N_VAL(id_node);
  481.     sem_list(opt_discr);
  482.     priv_kind_str = N_VAL(priv_kind_node);
  483.     if (streq(priv_kind_str, "private"))
  484.         priv_kind = symbol_private;
  485.     else if (streq(priv_kind_str, "limited_private"))
  486.         priv_kind = symbol_limited_private;
  487.     else {
  488.         printf("private_decl: invalid priv_kind_str %s\n",
  489.             priv_kind_str);
  490.         chaos("bad priv_kind_str");
  491.     }
  492.  
  493.     if (dcl_get(DECLARED(scope_name), id) == (Symbol)0) {
  494.         name = find_new(id);
  495.         TYPE_OF(name) = priv_kind;
  496.         root_type(name) = name;
  497.         process_discr(name, opt_discr);
  498.         NATURE(name) = na_type;
  499.         /*initialize_representation_info(name, TAG_RECORD);*/
  500.         /* This should be private_dependents (in SETL, it is the same as 
  501.          *   misc_type_attributes)
  502.          *   misc_type_attributes(name) = 0; 
  503.          */
  504.         private_dependents(name) = set_new(0);
  505.         popscope();
  506.  
  507.         nat = NATURE(scope_name);
  508.         if (nat!=na_package_spec && nat !=na_generic_package_spec
  509.           && nat!=na_generic_part) {
  510. #ifdef ERRNUM
  511.             errmsgn(396, 397, node);
  512. #else
  513.             errmsg("Invalid context for private declaration", "7.4, 12.1.2",
  514.               node);
  515. #endif
  516.         }
  517.     }
  518.     else{
  519. #ifdef ERRNUM
  520.         errmsgn(398, 399, id_node);
  521. #else
  522.         errmsg("Invalid redeclaration ", "8.2", id_node);
  523. #endif
  524.         name = symbol_any;
  525.     }
  526.  
  527.     N_UNQ(id_node) = name;
  528. }
  529.  
  530. void check_fully_declared(Symbol type_mark)            /*;check_fully_declared*/
  531. {
  532.     /* Called from object and constant declarations, to ensure that a
  533.      * private or incomplete type is not used in a declaration before its
  534.      * full declaration has been seen.
  535.      */
  536.  
  537.     Symbol    t;
  538.  
  539.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  check_fully_declared");
  540.  
  541.     t = base_type(type_mark);
  542.  
  543.     if (TYPE_OF(t) == symbol_incomplete || private_ancestor(t) != (Symbol)0) {
  544. #ifdef ERRNUM
  545.         id_errmsgn(400, type_mark, 401, current_node);
  546. #else
  547.         errmsg_id("invalid use of type % before its full declaration",
  548.           type_mark, "3.8.1, 7.4.1", current_node);
  549. #endif
  550.     }
  551.     /* If the type is a generic private type, and is used as an unconstrained
  552.      * subtype indication, note that its instantiations will have to be
  553.      * with a constrained type.
  554.      */
  555.     check_generic_usage(type_mark);
  556. }
  557.  
  558. void check_fully_declared2(Symbol type_mark)        /*;check_fully_declared2*/
  559. {
  560.     /* Called from array element and component declarations, to ensure that
  561.      * an incomplete type is not used in a declaration before its
  562.      * full declaration has been seen.
  563.      */
  564.  
  565.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  check_fully_declared2");
  566.  
  567.     check_incomplete(type_mark);
  568.     check_generic_usage(type_mark);
  569. }
  570.  
  571. int is_private(Symbol type_mark)                            /*;is_private*/
  572. {
  573.     /* Determine whether a type has a private subcomponent. This differs
  574.      * from what is done in private_ancestor, where only incomplete priv.
  575.      * subcomponents are of interest.
  576.      */
  577.  
  578.     Fordeclared    fd1;
  579.     char        *id;
  580.     Symbol        comp;
  581.  
  582.     if (in_priv_types(TYPE_OF(base_type(type_mark))) ) return TRUE;
  583.     if (in_priv_types(TYPE_OF(root_type(type_mark))) ) return TRUE;
  584.     if (is_array(type_mark) && is_private(component_type(type_mark)))
  585.         return TRUE;
  586.  
  587.     if (is_record(type_mark)) {
  588.         FORDECLARED(id, comp ,
  589.           (Declaredmap) declared_components(base_type(type_mark)), fd1)
  590.             if (is_private(TYPE_OF(comp)) ) return TRUE;
  591.         ENDFORDECLARED(fd1);
  592.         return FALSE;
  593.     }
  594. }
  595.  
  596. int is_limited_type(Symbol type_mark)    /*;is_limited_type*/
  597. {
  598.     /* A type is limited if its root type is a limited private type or a task
  599.      * type, or if it is a composite type some of whose components are limit-
  600.      * ted. The attributes 'limited' and 'limited private' are attached to
  601.      * such composite types when they are created by a definition, derivation
  602.      * or subtype declaration.
  603.      */
  604.  
  605.     Fordeclared    fd1;
  606.     int    mt;
  607.     char    *id;
  608.     Symbol    comp;
  609.  
  610.     if (TYPE_OF(base_type(type_mark)) == symbol_limited_private) return TRUE;
  611.     if (TYPE_OF(root_type(type_mark)) == symbol_limited_private) return TRUE;
  612.     if (is_task_type(type_mark)) return TRUE;
  613.  
  614.     mt = (int) misc_type_attributes(type_mark);
  615.  
  616.     if ((mt & TA_LIMITED) && (! is_access(type_mark))) return TRUE;
  617.  
  618.     if ((mt & TA_LIMITED_PRIVATE) == 0)     return FALSE;
  619.     if (! in_open_scopes(SCOPE_OF(type_mark) ) && ! is_access(type_mark))
  620.         return TRUE;
  621.     if (is_array(type_mark) &&    is_limited_type(component_type(type_mark)))
  622.         return TRUE;
  623.     if (is_record(type_mark) == FALSE) return FALSE;
  624.     FORDECLARED(id, comp, 
  625.       (Declaredmap)declared_components(base_type(type_mark)), fd1)
  626.         if (is_limited_type(TYPE_OF(comp)) )  return TRUE;
  627.     ENDFORDECLARED(fd1)
  628.     return FALSE;
  629. }
  630.  
  631. void check_out_parameters(Tuple formals)             /*;check_out_parameters */
  632. {
  633.     /*  enforce restrictions on usage of out formal parameters given in
  634.      *  LRM 7.4.4
  635.      */
  636.  
  637.     Symbol type_mark, scope;
  638.     Fortup ft;
  639.     int  nat, mode;
  640.     Tuple tup;
  641.  
  642.     FORTUP(tup=(Tuple), formals, ft);
  643.         mode = (int)tup[2];
  644.         type_mark = (Symbol)tup[3];
  645.         scope = SCOPE_OF(type_mark);
  646.         nat = NATURE(scope);
  647.         if (mode != na_out || is_access(type_mark))
  648.             continue;
  649.         else if (TYPE_OF(type_mark) == symbol_limited_private
  650.           && (nat == na_package_spec || nat == na_generic_package_spec 
  651.           || nat == na_generic_part )
  652.           && !in_private_part(scope) && tup_mem((char *)scope, open_scopes) ) {
  653.             /* We    are in the visible  part of  the package that declares
  654.              * the type. Its  full  decl. will  have to be  given with an
  655.              * assignable type.
  656.              */
  657.             misc_type_attributes(type_mark) =  
  658.               (misc_type_attributes(type_mark)) | TA_OUT;
  659.         }
  660.         else if (is_limited_type(type_mark)) {
  661. #ifdef ERRNUM
  662.             id_errmsgn(33, type_mark, 34, current_node);
  663. #else
  664.             errmsg_id("Invalid use of limited type % for out parameter ",
  665.               type_mark, "7.4.4", current_node);
  666. #endif
  667.         }
  668.     ENDFORTUP(ft);
  669. }
  670.  
  671. int in_private_part(Symbol scope)                    /*;in_private_part */
  672. {
  673.     Fortup ft;
  674.     Symbol sym;
  675.  
  676.     FORTUP(sym=(Symbol), open_scopes, ft);
  677.         if (NATURE(sym) == na_private_part 
  678.           && streq(ORIG_NAME(sym), ORIG_NAME(scope)))
  679.             return TRUE;
  680.     ENDFORTUP(ft);
  681.     return FALSE;
  682. }
  683.  
  684. int private_kind(Symbol type_mark)                        /*;private_kind*/
  685. {
  686.     /* We must distinguish between fully limited types, such as task types,
  687.      * and    limited private types, which  are not limited  in the  defining
  688.      * package body. Limited private types become limited when used outside
  689.      * of their scope  of definition, and so  do composite    types with such
  690.      * components, or derived  types of them. This procedure is used to set
  691.      * the corresponding attribute in a type definition.
  692.      *   Generic  limited types  and composites of them are always limited.
  693.      * These attribtues are also used to detect premature access to composite
  694.      * types that have incomplete subcomponents. If a subcomponent is a generic
  695.      * private type, there is no question of premature access (e.g. it is legal
  696.      * to have aggregates of this composite type).
  697.      */
  698.     /* This procedure is only used to return one of the attributes maintained
  699.      * is misc_type_attributes, and hence returns one of the values
  700.      * TA_...
  701.      */
  702.  
  703.     Symbol    r, t;
  704.     int    kind, tattr;
  705.  
  706.     r = root_type(type_mark);
  707.     kind=0;
  708.     do {
  709.         if (is_scalar_type(type_mark))  {
  710.             kind = 0;
  711.             break;
  712.         }
  713.  
  714.         t = TYPE_OF(r);
  715.         if (t == symbol_private) {
  716.             kind = TA_PRIVATE;
  717.             break;
  718.         }
  719.         if (t == symbol_limited_private) {
  720.             kind = TA_LIMITED_PRIVATE;
  721.             break;
  722.         }
  723.  
  724.         tattr = (int)misc_type_attributes(type_mark);
  725.         if (tattr &TA_PRIVATE) {
  726.             kind = TA_PRIVATE;
  727.             break;
  728.         }
  729.         if (tattr & TA_LIMITED_PRIVATE) {
  730.             kind = TA_LIMITED_PRIVATE;
  731.             break;
  732.         }
  733.         if (tattr & TA_LIMITED) {
  734.             kind = TA_LIMITED;
  735.             break;
  736.         }
  737.         if (tattr & TA_INCOMPLETE) {
  738.             kind = TA_INCOMPLETE;
  739.             break;
  740.         }
  741.         if (is_task_type(type_mark)) {
  742.             kind =    TA_LIMITED;
  743.             break;
  744.         }
  745.  
  746.         if (is_access(type_mark)) {
  747.             t = TYPE_OF((Symbol)base_type((Symbol) designated_type(type_mark)));
  748.             if (t == symbol_private)
  749.                 kind = TA_PRIVATE;
  750.             else if (t == symbol_limited_private)
  751.                 kind = TA_LIMITED_PRIVATE;
  752.             else if (t == symbol_limited)
  753.                 kind = TA_LIMITED;
  754.             else if (t == symbol_incomplete)
  755.                 kind = TA_INCOMPLETE;
  756.         }
  757.     } while (0);
  758.  
  759.     if (kind == TA_LIMITED_PRIVATE
  760.       && (is_generic_type(type_mark) || ! in_open_scopes(SCOPE_OF(r))))
  761.         kind = TA_LIMITED;
  762.     if (kind == TA_PRIVATE && is_generic_type(type_mark)) kind = 0;
  763.     return (kind);
  764. }
  765.  
  766. int is_fully_private(Symbol type_mark)        /*;is_fully_private*/
  767. {
  768.     /* Check whether a composite type has an 'incomplete' private component.*/
  769.  
  770.     int    a;
  771.  
  772. #ifdef TBSN
  773.     const f_types = ['private', 'limited_private', 'incomplete'];
  774.  
  775.     return    is_set (a :
  776.         = misc_type_attributes(type_mark))
  777.             and exists kind in f_types | kind in a;
  778. #endif
  779.     a = (int) misc_type_attributes(base_type(type_mark));
  780.     return a & (TA_PRIVATE | TA_LIMITED_PRIVATE | TA_INCOMPLETE);
  781. }
  782.  
  783. void check_priv_decl(int kind, Symbol type_name)    /*;check_priv_decl*/
  784. {
  785.     /* Verify that the full declaration of a private type satisfies the
  786.      * restrictions stated in 7.4.1., 7.4.4.
  787.      */
  788.  
  789.     Tuple    disc_list;
  790.     Symbol    package_name, ps, t;
  791.     Set    attributes;
  792.     int    typeattr;
  793.     Forset    fs1;
  794.  
  795.     package_name = SCOPE_OF(type_name);
  796.     if (kind == TA_PRIVATE && is_limited_type(TYPE_OF(type_name)) ) {
  797. #ifdef ERRNUM
  798.         errmsgn(402, 37, current_node);
  799. #else
  800.         errmsg("Private type requires full declaration with non limited type",
  801.           "7.4.1", current_node);
  802. #endif
  803.         return;
  804.     }
  805.     else if (NATURE(type_name) == na_array) {
  806. #ifdef ERRNUM
  807.         l_errmsgn(403, 404, 37, current_node);
  808. #else
  809.         errmsg_l("Private type cannot be fully declared as an unconstrained",
  810.           " array type", "7.4.1", current_node);
  811. #endif
  812.         return;
  813.     }
  814.     else {
  815.         /* If the private type is not declared with discriminants, it cannot
  816.          * be instantiated with a type with discriminants. Retrieve the pri-
  817.          * vate declaration to find if discriminant list was present.
  818.          */
  819.         /* [-, -, [-, disc_list], attributes ] :=
  820.          *   private_decls(package_name)(type_name);
  821.          */
  822.         ps = private_decls_get(
  823.           (Private_declarations) private_decls(package_name), type_name);
  824.         disc_list = (Tuple) (SIGNATURE(ps))[3]; /*is 3rd comp. in C */
  825.         attributes = private_dependents(ps);
  826.         typeattr = misc_type_attributes(ps);
  827.  
  828.         if (can_constrain(type_name) && tup_size(disc_list) == 0) {
  829. #ifdef ERRNUM
  830.             l_errmsgn(405, 406, 37, current_node);
  831. #else
  832.             errmsg_l("Private type without discriminants cannot be given ",
  833.               "full declaration with discriminants", "7.4.1", current_node);
  834. #endif
  835.             /* and viceversa.*/
  836.         }
  837.         else if (tup_size(disc_list) != 0 && NATURE(type_name) !=na_record ) {
  838.             /* TBSL - see why following line commented out    ds 2 aug */
  839.             /*|| !has_discriminants(type_name)*/
  840. #ifdef ERRNUM
  841.                 l_errmsgn(407, 408, 37, current_node);
  842. #else
  843.                 errmsg_l("A private type with discriminants must be given ",
  844.                   "full declaration with a discriminated type", "7.4.1",
  845.                   current_node);
  846. #endif
  847.             /*    else if ('out' in_attributes ? {} {*/
  848.         }
  849.         else if ( (typeattr & TA_OUT) && is_limited_type(type_name) ) {
  850. #ifdef ERRNUM
  851.             l_errmsgn(409, 410, 34, current_node);
  852. #else
  853.             errmsg_l("Use of type for an OUT parameter requires full ",
  854.               "declaration  with non limited type", "7.4.4", current_node);
  855. #endif
  856.         }
  857.     }
  858.     /* Composite types defined in the package and which include a component
  859.      * whose type is type_name are now usable in full (if type_name itself is
  860.      * not limited). They  may be defined in the visible part of the package,
  861.      * or in the (current) private part.
  862.      * The private dependents are part of the attributes of the private type.
  863.      */
  864.     if (!is_limited_type(type_name)) {
  865.         if (attributes != (Set)0) {
  866.             FORSET(t=(Symbol), attributes, fs1);
  867.                 if (SCOPE_OF(t) == package_name || SCOPE_OF(t) == scope_name)  {
  868.                     /* Save visible definition before updating.*/
  869.                     private_decls_put((Private_declarations)
  870.                       private_decls(package_name), t);
  871.                     /* private_decls(package_name)(t) := SYMBTABF(t); */
  872.                     /*    set_less(misc_type_attributes(t) , kind);*/
  873.                     misc_type_attributes(t) =
  874.                       ((int)misc_type_attributes(t) & ~kind);
  875.                 }
  876.             ENDFORSET(fs1)
  877.         }
  878.     }
  879.     check_generic_usage(type_name);
  880. }
  881.  
  882. static int in_relevant_scopes(int n)                /*;in_relevant_scopes*/
  883. {
  884.     /* called from private_ancestor to test membership in 
  885.      * SETL constant tuple relevant_scopes
  886.      */
  887.  
  888.     return (n== na_package_spec || n == na_generic_package_spec
  889.       || n == na_private_part || n == na_generic_part);
  890. }
  891.  
  892. Symbol private_ancestor(Symbol type_name)    /*;private_ancestor*/
  893. {
  894.     /* A type name has  a private ancestor    if it  is a subtype of, or has a
  895.      * component which is a subtype of, a private type whose full definition
  896.      * has not been seen yet. If the private ancestor of  t is defined, then
  897.      * t cannot  appear in    a type derivation,  and its  elaboration must be
  898.      * performed after that of the ancestor.
  899.      */
  900.  
  901.     if (in_relevant_scopes(NATURE(scope_name))
  902.       || ((NATURE(scope_name) == na_record || NATURE(scope_name) == na_void)
  903.       && in_relevant_scopes(NATURE(SCOPE_OF(scope_name)))))
  904.         return trace_ancestor(type_name, tup_new(0));
  905.     else
  906.         return (Symbol)0;
  907. }
  908.  
  909. static Symbol trace_ancestor(Symbol type_name, Tuple seen_prev)
  910.                                                             /*;trace_ancestor*/
  911. {
  912.     Fordeclared    fd1;
  913.     char        *id;
  914.     Symbol        comp, pr;
  915.     int        nat;
  916.     Tuple        seen;
  917.  
  918. #ifdef TBSL
  919.     -- note that seen is declared as set in SETL 
  920. #endif
  921.     /* Insertion of type names to the tuple seen must remain local to current
  922.      * invocation of this recursive procedure and not affect the calling one.
  923.      * Thus, a local copy of the tuple is created upon each entry to this
  924.      * procedure.
  925.      * the parameter name seen has been changed to seen_prev.
  926.      */
  927.     seen = tup_copy(seen_prev);
  928.  
  929.     /* Recursive procedure to find the private components of a composite
  930.      * type. this procedure uses a collection variable in order to detect 
  931.      * (invalid) recursive type definitions of private types.
  932.       */
  933.     if (tup_mem((char *) type_name, seen)) {
  934. #ifdef ERRNUM
  935.         id_errmsgn(411, type_name, 412, current_node);
  936. #else
  937.         errmsg_id("recursive definition of private type %", type_name,
  938.           "7.2", current_node);
  939. #endif
  940.         return type_name;
  941.     }
  942.     else
  943.         seen = tup_with(seen, (char *) type_name);
  944.  
  945.     if (is_scalar_type(type_name)) return (Symbol)0;
  946.     else if (in_priv_types(TYPE_OF(type_name))
  947.       && in_open_scopes(SCOPE_OF(type_name))) {
  948.         if (!is_generic_type(type_name))
  949.             return type_name;
  950.         else           /* A generic type is never seen by the interpreter */
  951.             return (Symbol)0;
  952.     }
  953.     else {
  954.         nat = NATURE(type_name);
  955.         if (nat == na_subtype)
  956.             return trace_ancestor(base_type(type_name), seen);
  957.         else if (nat == na_array)
  958.             return trace_ancestor((Symbol) component_type(type_name), seen);
  959.         else if (nat == na_record) {
  960.             FORDECLARED(id, comp,
  961.                 (Declaredmap)declared_components(base_type(type_name)), fd1);
  962.                 /* anonymous subtypes are generated for subtype indications in
  963.                  * component declarations, and appear in the declared map of 
  964.                  * records, but need not be examined here. 
  965.                  */
  966.                 if (NATURE(comp) == na_subtype) continue;
  967.                 pr = trace_ancestor(TYPE_OF(comp), seen);
  968.                 if (pr!=(Symbol)0) return pr;
  969.             ENDFORDECLARED(fd1);
  970.         }
  971.         else if (nat == na_access)
  972.             /* Access types need not be deferred.*/
  973.             return (Symbol)0;
  974.     }
  975.     return (Symbol)0; /* If none of the above.*/
  976. }
  977.  
  978. static void private_part(Node priv_node)                    /*;private_part*/
  979. {
  980.     char *nam;
  981.     Symbol    u_name;
  982.     Fordeclared    fd1;
  983.     Private_declarations    pd;
  984.     Forprivate_decls    fp1;
  985.     Symbol    vis_decl;
  986.     int    nat;
  987.  
  988.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  private_part");
  989.  
  990.     nat = NATURE(scope_name);            /* save */
  991.     NATURE(scope_name) = na_private_part;
  992.     adasem(priv_node);
  993.     force_all_types();
  994.     NATURE(scope_name) = nat;            /* restore */
  995.     current_node = priv_node;
  996.     /* Check that private types and deferred constants received
  997.      * full declarations.
  998.      */
  999.  
  1000.     FORDECLARED(nam, u_name, DECLARED(scope_name), fd1 );
  1001.         if (IS_VISIBLE(fd1) && ((in_priv_types(TYPE_OF(u_name))
  1002.           && !is_generic_type(u_name) || NATURE(u_name) == na_constant
  1003.           && (Node)SIGNATURE(u_name) == OPT_NODE))) {
  1004.             /* Private object did not get private description.*/
  1005. #ifdef ERRNUM
  1006.             str_errmsgn(413, nam, 37, current_node);
  1007. #else
  1008.             errmsg_str("Missing full declaration in private part for %",
  1009.               nam, "7.4.1", current_node);
  1010. #endif
  1011.         }
  1012.     ENDFORDECLARED(fd1);
  1013.     /* Now exchange contents of private_decls and symbol table. In this
  1014.      * fashion the declarations that were visible in the private part of
  1015.      * the package, and that will be visible in the package body, become
  1016.      * inaccessible outside of the package specification.
  1017.      */
  1018.     pd = (Private_declarations) private_decls(scope_name);
  1019.     FORPRIVATE_DECLS(u_name, vis_decl, pd, fp1);
  1020.         private_decls_swap(u_name, vis_decl);
  1021.     ENDFORPRIVATE_DECLS(fp1);
  1022. }
  1023.  
  1024. void end_specs(Symbol nam)        /*;end_specs*/
  1025. {
  1026.     /* This procedure is invoked at the end of a module specification.
  1027.      * If this spec. is a compilation unit, then we save in UNIT_DECL
  1028.      * all the declarations processed for the module. These declarations
  1029.      * are retrieved (by procedure get_specs) when the separate compilation
  1030.      * facility is used.
  1031.      * In the case of generic modules, we must we must save the
  1032.      * specs of the generic object in its signature, to simplify its instan-
  1033.      * tiation. In order to insure that a separately compiled generic object
  1034.      * is properly saved, we make the object name accessible within its own
  1035.      * scope. This insures that its symbol table entry is correctly saved.
  1036.      */
  1037.  
  1038.     int    kind;
  1039.     Tuple    old_vis, vis_units;
  1040.     Fortup    ft1;
  1041.     Symbol    v;
  1042.     char    *v_spec_name;
  1043.  
  1044.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : end_specs(nam) ");
  1045.  
  1046.     kind = NATURE(nam);
  1047.  
  1048.     /* save visible mods for this scope.*/
  1049.     old_vis = tup_new(0);
  1050.     FORTUP(v=(Symbol), vis_mods, ft1);
  1051.         if (v!=symbol_ascii)
  1052.             old_vis = tup_with(old_vis, (char *) v);
  1053.         /*old_vis = [v in vis_mods | v /= 'ASCII'];*/
  1054.     ENDFORTUP(ft1);
  1055.  
  1056.     popscope();
  1057.  
  1058.     vis_units = tup_new(0);
  1059.     FORTUP(v=(Symbol), old_vis, ft1);
  1060.         v_spec_name = strjoin("sp", original_name(v));
  1061.         if (unitNumberFromName(v_spec_name))
  1062.             vis_units = tup_with(vis_units, original_name(v));
  1063.     ENDFORTUP(ft1);
  1064.  
  1065.     if (IS_COMP_UNIT)
  1066.         save_spec_info(nam, vis_units);
  1067.     else {
  1068.         /* If the module is a sub-unit, make sure that it is visible in
  1069.          * its enclosing scope (except if it is a generic package).
  1070.          */
  1071.         FORTUP(v=(Symbol), old_vis, ft1);
  1072.             if (! tup_mem((char *) v, vis_mods))
  1073.                 vis_mods = tup_with(vis_mods, (char *) v);
  1074.         ENDFORTUP(ft1);
  1075.         /*vis_mods +:= [v in old_vis | v notin vis_mods];*/
  1076.         if (kind != na_generic_package_spec)
  1077.             vis_mods =  tup_with(vis_mods, (char *) nam);
  1078.     }
  1079. }
  1080.  
  1081. void check_incomplete_decls(Symbol scope, Node msg_node)
  1082.                                                     /*;check_incomplete_decls*/
  1083. {
  1084.     /* At the end of a block, verify that entities that need a body received
  1085.      * one.
  1086.      */
  1087.  
  1088.     Fordeclared    fd1;
  1089.     Fortup    ft1;
  1090.     char    *id, *stub;
  1091.     Symbol    name;
  1092.     int    exists;
  1093.  
  1094.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : check_incomplete_decls");
  1095.  
  1096.     if (DECLARED(scope) != (Declaredmap)0) {
  1097.         FORDECLARED(id, name, DECLARED(scope), fd1);
  1098.             if (needs_body(name) && !is_anonymous_task(name)) {
  1099.                 exists = FALSE;
  1100.                 FORTUP(stub=(char *), lib_stub, ft1);
  1101.                     if (streq(unit_name_name(stub), original_name(name)))
  1102.                         exists = TRUE;
  1103.                 ENDFORTUP(ft1);
  1104.                 if (!exists)  {
  1105. #ifdef ERRNUM
  1106.                     nat_id_str_errmsgn(416, name, scope, id, 417, msg_node);
  1107. #else
  1108.                     errmsg_nat_id_str("Missing body for % %.%", name, scope,
  1109.                       id, "7.3", msg_node);
  1110. #endif
  1111.                     continue;
  1112.                 }
  1113.             }
  1114.             if (TYPE_OF(name) == symbol_incomplete) {
  1115. #ifdef ERRNUM
  1116.                 str_errmsgn(418, id, 5, msg_node);
  1117. #else
  1118.                 errmsg_str(
  1119.                   "Missing full type declaration for incomplete type %",
  1120.                   id, "3.8.1", msg_node);
  1121. #endif
  1122.             }
  1123.         ENDFORDECLARED(fd1);
  1124.     }
  1125. }
  1126.  
  1127. Symbol get_specs(char *name)        /*;get_specs*/
  1128. {
  1129.     /* Install the specification for a package. This is done in two cases :
  1130.      * a) When we process the WITH clause of a new compilation unit.
  1131.      * b) When we compile the body of a package. The corresponding
  1132.      * package specification must have been compiled already, an must be
  1133.      * available. 
  1134.      */
  1135.  
  1136.     char    *spec_name, *u;
  1137.     int    i, notin;
  1138.     Tuple    decscopes, decmaps, vis_units, specs;
  1139.     Symbol    v, sn;
  1140.     Fortup    ft1, ft2;
  1141.     Symbol    unit_unam, uname, maybe_decl;
  1142.     Unitdecl ud;
  1143.  
  1144.     if (cdebug2 > 3) {
  1145.         TO_ERRFILE("AT PROC :  get_specs");
  1146.         printf("get_specs for %s\n", name);
  1147.     }
  1148.  
  1149.     spec_name = strjoin("sp", name);
  1150.     if (!retrieve(spec_name)) {
  1151. #ifdef ERRNUM
  1152.         str_errmsgn(419, name, 8, current_node);
  1153. #else
  1154.         errmsg_str("Cannot find package specification for %", name, "10.1",
  1155.           current_node);
  1156. #endif
  1157.         return (Symbol)0;
  1158.     }
  1159.     /* Read in the unique names and the declared types of all visible
  1160.      * names in the module specification.
  1161.      */
  1162.     /*[unit_unam, specs, decmap, old_vis, notvis] := UNIT_DECL(spec_name);*/
  1163.     ud = unit_decl_get(spec_name);
  1164.     if (ud == (Unitdecl) 0) chaos("get_specs, unit_decl_get returned 0 - exit");
  1165.     unit_unam = ud->ud_unam;
  1166.     specs = ud->ud_symbols;
  1167.     decscopes = ud->ud_decscopes;
  1168.     vis_units = ud->ud_oldvis;
  1169.     decmaps = ud->ud_decmaps;
  1170.  
  1171.     /* SYMTAB restore */
  1172.     symtab_restore(specs);
  1173.  
  1174.     /* (for dec = decmap(sn))
  1175.      * declared(sn) := dec;
  1176.      * if notvis(sn) /= om then   $ only defined for non-generic packages.
  1177.      * visible(sn) :=    dec - notvis(sn);
  1178.      * end if;
  1179.      * end for;
  1180.      */
  1181.     FORTUPI(sn=(Symbol), decscopes, i, ft1);
  1182.         /* TBSL - see if need do dcl_copy when restore, as did copy when saved*/
  1183. #ifdef TBSL
  1184.     -- translate if notvis(sn)... test above to C    ds 2-jan-85 
  1185.         -- need loop over declared map to see if any entries not visible.
  1186. #endif
  1187.         if (decmaps[i]!=(char *)0)
  1188.             DECLARED(sn) = dcl_copy((Declaredmap) decmaps[i]);
  1189.     ENDFORTUP(ft1);
  1190.     /*
  1191.      * Predefined unit that are mentioned in a WITH clauses are not saved in
  1192.      * UNIT_LIB, for storage reasons. Their contents must be brought in ex-
  1193.      * plicitly, but their direct visibility must not be modified.
  1194.      */
  1195.     /* (for u in vis_units | u notin vis_mods) */
  1196.     FORTUP(u=(char *), vis_units, ft1);
  1197.         notin = TRUE;
  1198.         FORTUP(v=(Symbol), vis_mods, ft2);
  1199.             if (streq(u, original_name(v))) notin = FALSE;
  1200.         ENDFORTUP(ft2);
  1201.         if (notin) {
  1202.             maybe_decl = dcl_get(DECLARED(symbol_standard0), u);
  1203.             uname = get_specs(u);
  1204.             vis_mods = tup_with(vis_mods, (char *)  uname);
  1205.         }
  1206.     ENDFORTUP(ft1);
  1207.     if (dcl_get(DECLARED(symbol_standard0), name) == (Symbol)0)
  1208.         dcl_put(DECLARED(symbol_standard0), name, unit_unam);
  1209.     return unit_unam;
  1210. }
  1211.